home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 May / Macworld (1999-05).dmg / Updaters / Workplace Client 4.2 / TeamWave Workplace / TeamWave Workplace.rsrc / TEXT_17_msgbox.txt < prev    next >
Text File  |  1999-03-03  |  7KB  |  256 lines
  1. # msgbox.tcl --
  2. #
  3. #    Implements messageboxes for platforms that do not have native
  4. #    messagebox support.
  5. #
  6. # SCCS: @(#) msgbox.tcl 1.8 97/07/28 17:20:01
  7. #
  8. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13.  
  14.  
  15. # tkMessageBox --
  16. #
  17. #    Pops up a messagebox with an application-supplied message with
  18. #    an icon and a list of buttons. This procedure will be called
  19. #    by tk_messageBox if the platform does not have native
  20. #    messagebox support, or if the particular type of messagebox is
  21. #    not supported natively.
  22. #
  23. #    This procedure is a private procedure shouldn't be called
  24. #    directly. Call tk_messageBox instead.
  25. #
  26. #    See the user documentation for details on what tk_messageBox does.
  27. #
  28. proc tkMessageBox {args} {
  29.     global tkPriv tcl_platform
  30.  
  31.     set w tkPrivMsgBox
  32.     upvar #0 $w data
  33.  
  34.     #
  35.     # The default value of the title is space (" ") not the empty string
  36.     # because for some window managers, a 
  37.     #        wm title .foo ""
  38.     # causes the window title to be "foo" instead of the empty string.
  39.     #
  40.     set specs {
  41.     {-default "" "" ""}
  42.         {-icon "" "" "info"}
  43.         {-message "" "" ""}
  44.         {-parent "" "" .}
  45.         {-title "" "" " "}
  46.         {-type "" "" "ok"}
  47.     }
  48.  
  49.     tclParseConfigSpec $w $specs "" $args
  50.  
  51.     if {[lsearch {info warning error question} $data(-icon)] == -1} {
  52.     error "invalid icon \"$data(-icon)\", must be error, info, question or warning"
  53.     }
  54.     if {$tcl_platform(platform) == "macintosh"} {
  55.     if {$data(-icon) == "error"} {
  56.         set data(-icon) "stop"
  57.     } elseif {$data(-icon) == "warning"} {
  58.         set data(-icon) "caution"
  59.     } elseif {$data(-icon) == "info"} {
  60.         set data(-icon) "note"
  61.     }
  62.     }
  63.  
  64.     if ![winfo exists $data(-parent)] {
  65.     error "bad window path name \"$data(-parent)\""
  66.     }
  67.  
  68.     case $data(-type) {
  69.     abortretryignore {
  70.         set buttons {
  71.         {abort  -width 6 -text Abort -under 0}
  72.         {retry  -width 6 -text Retry -under 0}
  73.         {ignore -width 6 -text Ignore -under 0}
  74.         }
  75.     }
  76.     ok {
  77.         set buttons {
  78.         {ok -width 6 -text OK -under 0}
  79.         }
  80.         if {$data(-default) == ""} {
  81.         set data(-default) "ok"
  82.         }
  83.     }
  84.     okcancel {
  85.         set buttons {
  86.         {ok     -width 6 -text OK     -under 0}
  87.         {cancel -width 6 -text Cancel -under 0}
  88.         }
  89.     }
  90.     retrycancel {
  91.         set buttons {
  92.         {retry  -width 6 -text Retry  -under 0}
  93.         {cancel -width 6 -text Cancel -under 0}
  94.         }
  95.     }
  96.     yesno {
  97.         set buttons {
  98.         {yes    -width 6 -text Yes -under 0}
  99.         {no     -width 6 -text No  -under 0}
  100.         }
  101.     }
  102.     yesnocancel {
  103.         set buttons {
  104.         {yes    -width 6 -text Yes -under 0}
  105.         {no     -width 6 -text No  -under 0}
  106.         {cancel -width 6 -text Cancel -under 0}
  107.         }
  108.     }
  109.     default {
  110.         error "invalid message box type \"$data(-type)\", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel"
  111.     }
  112.     }
  113.  
  114.     if [string compare $data(-default) ""] {
  115.     set valid 0
  116.     foreach btn $buttons {
  117.         if ![string compare [lindex $btn 0] $data(-default)] {
  118.         set valid 1
  119.         break
  120.         }
  121.     }
  122.     if !$valid {
  123.         error "invalid default button \"$data(-default)\""
  124.     }
  125.     }
  126.  
  127.     # 2. Set the dialog to be a child window of $parent
  128.     #
  129.     #
  130.     if [string compare $data(-parent) .] {
  131.     set w $data(-parent).__tk__messagebox
  132.     } else {
  133.     set w .__tk__messagebox
  134.     }
  135.  
  136.     # 3. Create the top-level window and divide it into top
  137.     # and bottom parts.
  138.  
  139.     catch {destroy $w}
  140.     toplevel $w -class Dialog
  141.     wm title $w $data(-title)
  142.     wm iconname $w Dialog
  143.     wm protocol $w WM_DELETE_WINDOW { }
  144.     wm transient $w $data(-parent)
  145.     if {$tcl_platform(platform) == "macintosh"} {
  146.     unsupported1 style $w dBoxProc
  147.     }
  148.  
  149.     frame $w.bot
  150.     pack $w.bot -side bottom -fill both
  151.     frame $w.top
  152.     pack $w.top -side top -fill both -expand 1
  153.     if {$tcl_platform(platform) != "macintosh"} {
  154.     $w.bot configure -relief raised -bd 1
  155.     $w.top configure -relief raised -bd 1
  156.     }
  157.  
  158.     # 4. Fill the top part with bitmap and message (use the option
  159.     # database for -wraplength so that it can be overridden by
  160.     # the caller).
  161.  
  162.     option add *Dialog.msg.wrapLength 3i widgetDefault
  163.     label $w.msg -justify left -text $data(-message)
  164.     
  165.     pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
  166.     if {$data(-icon) != ""} {
  167.     label $w.bitmap -bitmap $data(-icon)
  168.     pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
  169.     }
  170.  
  171.     # 5. Create a row of buttons at the bottom of the dialog.
  172.  
  173.     set i 0
  174.     foreach but $buttons {
  175.     set name [lindex $but 0]
  176.     set opts [lrange $but 1 end]
  177.     if ![string compare $opts {}] {
  178.         # Capitalize the first letter of $name
  179.         set capName \
  180.         [string toupper \
  181.             [string index $name 0]][string range $name 1 end]
  182.         set opts [list -text $capName]
  183.     }
  184.  
  185.     eval button $w.$name $opts -command [list "set tkPriv(button) $name"]
  186.  
  187.     if ![string compare $name $data(-default)] {
  188.         $w.$name configure -default active
  189.     }
  190.     pack $w.$name -in $w.bot -side left -expand 1 \
  191.         -padx 3m -pady 2m
  192.  
  193.     # create the binding for the key accelerator, based on the underline
  194.     #
  195.     set underIdx [$w.$name cget -under]
  196.     if {$underIdx >= 0} {
  197.         set key [string index [$w.$name cget -text] $underIdx]
  198.         bind $w <Alt-[string tolower $key]>  "$w.$name invoke"
  199.         bind $w <Alt-[string toupper $key]>  "$w.$name invoke"
  200.     }
  201.     incr i
  202.     }
  203.  
  204.     # 6. Create a binding for <Return> on the dialog if there is a
  205.     # default button.
  206.  
  207.     if [string compare $data(-default) ""] {
  208.     bind $w <Return> "tkButtonInvoke $w.$data(-default)"
  209.     }
  210.  
  211.     # 7. Withdraw the window, then update all the geometry information
  212.     # so we know how big it wants to be, then center the window in the
  213.     # display and de-iconify it.
  214.  
  215.     wm withdraw $w
  216.     update idletasks
  217.     set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
  218.         - [winfo vrootx [winfo parent $w]]]
  219.     set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
  220.         - [winfo vrooty [winfo parent $w]]]
  221.     wm geom $w +$x+$y
  222.     wm deiconify $w
  223.  
  224.     # 8. Set a grab and claim the focus too.
  225.  
  226.     set oldFocus [focus]
  227.     set oldGrab [grab current $w]
  228.     if {$oldGrab != ""} {
  229.     set grabStatus [grab status $oldGrab]
  230.     }
  231.     grab $w
  232.     if [string compare $data(-default) ""] {
  233.     focus $w.$data(-default)
  234.     } else {
  235.     focus $w
  236.     }
  237.  
  238.     # 9. Wait for the user to respond, then restore the focus and
  239.     # return the index of the selected button.  Restore the focus
  240.     # before deleting the window, since otherwise the window manager
  241.     # may take the focus away so we can't redirect it.  Finally,
  242.     # restore any grab that was in effect.
  243.  
  244.     tkwait variable tkPriv(button)
  245.     catch {focus $oldFocus}
  246.     destroy $w
  247.     if {$oldGrab != ""} {
  248.     if {$grabStatus == "global"} {
  249.         grab -global $oldGrab
  250.     } else {
  251.         grab $oldGrab
  252.     }
  253.     }
  254.     return $tkPriv(button)
  255. }
  256.